home *** CD-ROM | disk | FTP | other *** search
/ CD Actual 9 / CDACTUAL9.iso / share / Dos / VARIOS / pascal / MISC.SWG / 0002_TURBO PONG GAME.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1996-02-21  |  8.4 KB  |  243 lines
  1.  
  2. uses crt, dos;  {$R-}
  3. (****************************************************************************)
  4. (*           TPONG-1.PAS        Glenn A. Reiff    74035,400     4/5/85      *)
  5. (*                                                                          *)
  6. (*  Note:  While this program is usable and will provide some fun, the      *)
  7. (*         Paddle control is not as responsive as it is in the original     *)
  8. (*         Basic program.  Also, the side bounces could be better.  If      *)
  9. (*         you are able to make any improvements I'd appreciate knowing     *)
  10. (*         about them.                                                      *)
  11. (****************************************************************************)
  12. type Str80 = string[80];
  13. procedure CENTER(Y:integer; Bt:Str80);
  14. BEGIN gotoXY((80-Length(Bt)) div 2, Y); write(Bt) END;
  15.  
  16. procedure INTRODUCTION;
  17. BEGIN
  18.      clrscr;                    CENTER(5,'TURBO PONG');
  19.      CENTER(8,'This is an adaption to Turbo Pascal of the Basic program  ');
  20.      CENTER(9,'called PChallenge written by Karl Koessel and published in');
  21.      CENTER(10,'a 1982 issue of PC Magazine.                              ');
  22.      CENTER(12,'His was a simplification of Pong, the orignial video game.');
  23.      CENTER(13,'Pong was developed in the early 1970''s by Nolan Bushnell. ');
  24.      CENTER(20,'Tap a Key to Continue');
  25.      writeln; gotoXY(80,25);
  26.      repeat until keypressed;
  27. END; { INTRODUCTION }
  28.  
  29.  
  30. type       CharSet = set of Char;
  31.            Str9    = string[9];
  32.  
  33. var        Paddle  : Str9;
  34.            StartTime,
  35.            EndTime,
  36.            CurTime,
  37.            BestTime,
  38.            Drag : integer;
  39.            Ch: char;
  40.  
  41.  
  42. Procedure TEXTBORDER (color: integer);
  43.   var regs: registers;
  44. BEGIN
  45.   With regs do begin
  46.     AH := 11; BH := 0; BL := color end;
  47.   Intr($10,regs)
  48. END; { TEXTBORDER }
  49.  
  50. Procedure BEEP(N : Integer);
  51. BEGIN   Sound(n);  Delay(100);  NoSound; END;
  52.  
  53. function GET_TIME: integer;
  54. var regs: registers;
  55. BEGIN
  56.   with regs do begin
  57.     ax := $2C * 256;
  58.     MsDos(regs);
  59.     GET_TIME := 3600 * ch + 60 * cl + dh
  60.   end
  61. END;  { GET_TIME }
  62.  
  63. procedure CHOOSE(    X,Y    : integer;
  64.                      Prompt : Str80;
  65.                      Term   : CharSet;
  66.                  var TC     : Char    );
  67. var   I  : integer;
  68.       Ch : char;
  69. BEGIN
  70.   lowvideo; gotoXY(X,Y);
  71.   for I:=1 to length(Prompt) do begin
  72.       Ch:=Prompt[I];
  73.       if I>4 then begin
  74.         lowvideo;
  75.         if (Prompt[I-2]=' ') and (Prompt[I-1]=' ') then highvideo;
  76.         if (Prompt[I-1]='<') or  (Prompt[I-1]='/') then highvideo;
  77.       end; { if I>3 }
  78.       write(Ch)
  79.   end; { for I }
  80.   repeat
  81.     TC := Upcase(ReadKey);
  82.     if not (TC in Term) then BEEP(1000)
  83.   until TC in Term
  84. END; { CHOOSE }
  85.  
  86. procedure RESET(var Drag: integer;  var Paddle: Str9);
  87. BEGIN
  88.      TEXTBORDER(Black); textbackground(Black); clrscr;
  89.      CENTER(10,'Left and right cursor keys move paddle.');
  90.      textcolor(LightCyan);
  91.      CENTER(12,'Input drag factor: (100 is Medium...0 is FAST!)  ');
  92. read(Drag);     CHOOSE(17,14,'Pick a paddle size:  Small,  Medium or
  93. Large',['S','M','L'],Ch);     if Ch = 'S' then Paddle := ' '+chr(27)+'
  94. '+chr(26)+' '       else if Ch = 'M' then Paddle := ' '+chr(27)+'
  95. '+chr(26)+' '          else if Ch = 'L' then Paddle := ' '+chr(27)+'
  96. '+chr(26)+' 'END; { RESET }
  97.  
  98. procedure RUN;
  99. label NewBall;
  100. var   Used                                 :   array[1..10] of integer;
  101. var   X,dX,Xpad,Y,dY,B,C,I,J,BallNr,Xstart :   integer;
  102.       Flag                                 :   boolean;
  103.  
  104.   procedure RANDOMIZE;
  105.   BEGIN
  106.     dx := random(7)- integer (random(7));
  107.     if dX < 0  then
  108.       repeat
  109.         dX := random(7) - integer (random(7));
  110.         if dX=0 then dX:=-1;
  111.       until (X-6)/dX=trunc((X-6)/dX);
  112.     if dX > 0  then
  113.       repeat
  114.         dX := random(7) - integer (random(7));
  115.         if dX=0 then dX:=1;
  116.       until (59-X)/dX=trunc((59-X)/dX)
  117.   END; { RANDOMIZE }
  118.  
  119.   procedure POSITION_PADDLE;
  120.   BEGIN
  121.     gotoXY(Xpad,22); textbackground(LightGray);
  122.     textcolor(DarkGray); write(Paddle); textbackground(C);
  123.   END; { POSITION_PADDLE }
  124.  
  125.   procedure ONKEY;
  126.   BEGIN
  127.     Ch := ReadKey;
  128.     if Ch = #27 then  { it must be a function key }
  129.       Ch := ReadKey;
  130.     case Ch of
  131.       'K':   if Xpad > 7 then begin
  132.         Xpad:=Xpad-3; POSITION_PADDLE;
  133.         gotoXY(Xpad+length(Paddle),22); write('   '); end;
  134.       'M':   if Xpad + length(Paddle) < 60 then begin
  135.         Xpad:=Xpad+2; POSITION_PADDLE;
  136.         gotoXY(Xpad-3,22); write('   '); end;
  137.     end;   { case }
  138.   END; { ONKEY }
  139.  
  140.  
  141. BEGIN
  142.      J := 11; Xpad := 29; C := random(16);
  143.      if c in [0, 1, 6..9, 12, 15] then C := 2;
  144.      textbackground(C); clrscr; TEXTBORDER(C);
  145.  
  146.      for X:=8 to 17 do begin   { Setup  10 Balls }
  147.          J := J + 4; textbackground(red); textcolor(white);
  148.          gotoXY(J,2); write(#2); textbackground(C);
  149.      end; { for X }
  150.      textcolor(Blue);
  151.      GotoXY (5, 3);
  152.      for X:=5 to 59 do write(#219);  { Draw Backboard }
  153.      for Y:=3 to 21 do begin         { Draw Walls  }
  154.         gotoXY  (5,Y); write (#219#219);
  155.         gotoXY (59,Y); write (#219#219);
  156.      end;
  157.      POSITION_PADDLE; textcolor(Black);
  158.      gotoXY(5,24); write('Best Time so far is ',BestTime,' seconds.');
  159.      gotoXY(66,3); write('TURBOPONG');
  160.      gotoXY(63,6); write('Initial Drag ',Drag);
  161.      FillChar (Used, 20, 0);
  162.      BallNr := 10;
  163.      StartTime := GET_TIME;
  164.  
  165.      while BallNr > 0 do begin
  166.        repeat
  167.          Xstart := 1 + random(10); Flag:=false;
  168.          for I:=1 to 10 do if Used[I] = Xstart then Flag:=true;
  169.        until not Flag;
  170.        Used[BallNr]:=Xstart;
  171.        Xstart := 11 + 4 * Xstart;
  172.        gotoXY(Xstart,2); write(' ');
  173.        X := Xstart; Y := 4; dY := 1; Flag := false;
  174.        RANDOMIZE;
  175.        while Y < 23 do begin
  176.          if keypressed then ONKEY;
  177.          textbackground(C);
  178.          if (Y > 4)  and (X in [7..58]) then     { Erase Previous Ball Below }
  179.            begin gotoXY(X,Y-1); write(' '); end;
  180.          if (Y < 21) and (X in [7..58]) then
  181.            begin gotoXY(X,Y+1); write(' '); end; { Erase Previous Ball Above }
  182.          if (Y=21) and (X-Xpad in [0..length (Paddle)]) then
  183.            begin gotoXY(X,Y); write(' '); end;   { Erase Ball On Paddle      }
  184.  
  185.          X:=X + dX;
  186.  
  187.          textbackground(red); textcolor(white);
  188.          if X in [7..58] then begin
  189.            gotoXY(X,Y); write(#1)         { Print New Ball Position }
  190.          end;
  191.          gotoXY(80,25);
  192.          if not (x in [8..57]) then begin
  193.            BEEP(300+random(80*BallNr)); dX:=-dX;
  194.          end;    { Side Wall Bounce        }
  195.          if keypressed then ONKEY;
  196.  
  197.          if (Y=21) and (X-Xpad in [0..length(Paddle)]) then begin
  198.            dY := -dY; BEEP(700);      { Bounce Off Of Paddle }
  199.            if dX = 0 then RANDOMIZE;
  200.          end; { if Y=21 }
  201.  
  202.          if Y = 22 then begin
  203.            textbackground(C); gotoXY(X,Y); write(' ');
  204.            textbackground(red); textcolor(white);      { Park Used Ball }
  205.            gotoXY(25+Xstart,Y+2); write(#1); gotoXY(80,25);
  206.          end;
  207.          if keypressed then ONKEY;
  208.  
  209.          if (Y = 4) and Flag then begin   { Bounce Off of Top Backboard }
  210.            BEEP(300+random(80*BallNr));
  211.            Drag := Drag - 5;  { Reduce Amout of Drag    }
  212.            if dX = 0 then RANDOMIZE;
  213.            inc (dX); dY := -dY; Y := Y + dY
  214.          end else begin Y := Y + dY; Flag := true end;
  215.          if Drag <0 then Drag := 0;
  216.          delay(50+Drag);
  217.        end; { while Y }
  218.        BallNr := BallNr - 1; textbackground(C);
  219.      end; { while BallNr }
  220.      gotoXY(1,22); clreol;
  221.      textcolor(Black); gotoXY(63,8); if Drag < 0 then Drag := 0;
  222.      write('Final Drag   ',Drag);
  223.      EndTime := GET_TIME;
  224.      CurTime := EndTime - StartTime;
  225.      if CurTime > BestTime then BestTime := CurTime;
  226.      gotoXY  (5,24); write('Best Time so far is ',BestTime,' seconds.');
  227.      gotoXY (63,11); write('This Run ', CurTime, ' sec.');
  228. END; { RUN }
  229.  
  230. {MMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMM}
  231. BEGIN
  232.           BestTime := 0; Drag := 0; Paddle := '';
  233.           INTRODUCTION;
  234.           RESET(Drag,Paddle);
  235.           repeat
  236.             RUN;
  237.             CHOOSE(19,22,'    Quit  Reset  Continue   ',['Q','R','C'],Ch);
  238.             if Ch = 'R' then RESET(Drag,Paddle);
  239.           until Ch = 'Q';
  240.           TEXTBORDER(Black); textbackground(Black); clrscr;
  241. END.
  242.  
  243.